home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / sml_nj / 93src.lha / src / cps / contmap.sml < prev    next >
Encoding:
Text File  |  1993-01-27  |  14.3 KB  |  368 lines
  1. (**********************************************************************
  2.  * CONVENTIONS on the input to ContMap module:                        *
  3.  *   The cexp into the contmap function is directly from the cpsopt   *
  4.  *   module. We assume that every escaped functions have either one   *
  5.  *   or two arguments and the one-arguments excaped functions are     *
  6.  *   definitely continuations.                                        *
  7.  **********************************************************************)
  8. signature CONTMAP = sig
  9.    val contmap : CPS.function -> CPS.function * (CPS.lvar -> bool) 
  10.                                  * (CPS.lvar -> bool * CPS.lvar list)
  11. end
  12.  
  13. structure ContMap : CONTMAP = 
  14. struct
  15.     
  16. open CPS Access SortedList
  17.  
  18. (**********************************************************************
  19.  *               UTILITY FUNCTIONS AND CONSTANTS                      *
  20.  **********************************************************************)
  21. val error = ErrorMsg.impossible
  22.  
  23. fun clean l =
  24.     let fun vars(l, VAR x :: rest) = vars(x::l, rest)
  25.           | vars(l, _::rest) = vars(l,rest)
  26.           | vars(l, nil) = rev l
  27.      in vars(nil,l)
  28.     end
  29.  
  30. fun sublist test =
  31.     let fun subl(a::r) = if test a then a::(subl r) else subl r
  32.           | subl [] = []
  33.      in  subl
  34.     end
  35.  
  36. fun divlist test =
  37.     let fun divl(a::r) = let val (t1,t0) = divl r
  38.                           in if (test a) then (a::t1,t0)
  39.                              else (t1,a::t0)
  40.                          end
  41.           | divl [] = ([],[])
  42.      in divl
  43.     end
  44.  
  45. fun mixer(v::vl,t::tl) = (v::t)::mixer(vl,tl)
  46.   | mixer(nil,nil) = nil
  47.   | mixer _ = error "grouping known fun info with diff # of args"
  48.  
  49. fun grouping nil = nil 
  50.   | grouping (vl::nil) = map (fn x => [x]) vl
  51.   | grouping (vl::tl) =  mixer(vl,grouping tl)
  52.                         
  53. fun lookup(v,nil) = NONE
  54.   | lookup(v,(a,b)::tl) = if v = a then (SOME b) else lookup(v,tl)
  55.  
  56. fun clookup(v,env) = (case lookup(v,env) of NONE => v
  57.                                           | SOME v' => v')
  58.  
  59. fun glookup(VAR v,env) = VAR (clookup(v,env))
  60.   | glookup(x,env) = x
  61.  
  62. fun fix(nil,e) = e
  63.   | fix(fl,e) = FIX(fl,e)
  64.     
  65.  
  66. (**********************************************************************
  67.  *  contmap : CPS.function -> CPS.function * (CPS.lvar -> bool)       *
  68.  *                            * (CPS.lvar -> bool * CPS.lvar list)    *
  69.  *                                                                    *
  70.  * The function contmap eliminates all strange continuation variables *
  71.  * and generates accurate continuation variable information, the      *
  72.  * postion information and the free variable information              *
  73.  **********************************************************************)
  74. fun contmap(fvar,fargs,cexp) = 
  75. let val (_,_,known) = FreeMap.freemapClose(cexp)
  76.     val escapes = not o known
  77.  
  78.     exception Mcont
  79.     val t : (value list list) ref Intmap.intmap = Intmap.new(32,Mcont)
  80.     fun find v = (!(Intmap.map t v)) handle Mcont => nil
  81.     fun add(v,vl) = (let val a = Intmap.map t v
  82.                          val _ = (a := (vl::(!a)))
  83.                       in ()
  84.                      end) handle Mcont => Intmap.add t (v,ref([vl]))
  85.  
  86.     val contset = Intset.new()
  87.     fun iscont v = Intset.mem contset v
  88.     fun contM v = Intset.add contset v
  89.  
  90.     fun iscontv (VAR v) = iscont v 
  91.       | iscontv _ = false 
  92.  
  93.  
  94. (* cexp -> lvar list, i.e. known function name list. The side-effect is to 
  95.  * find all continuation variables and to put them into a hash table.
  96.  *)
  97.     val rec incinfo = fn (e,l) => (contvars e)@l
  98.     and contvars = 
  99.       fn RECORD(_,vl,w,e) => contvars e
  100.        | SELECT(i,v,w,e) => contvars e
  101.        | APP(f as (VAR g),vl) => 
  102.            if (escapes g) then 
  103.              (let val k = length(vl)
  104.                in if (k > 2) orelse (k < 1) 
  105.           then (error "escaped funs have > 2 or < 1 arguments z";
  106.                 nil)    
  107.           else if k = 1 then (contM g ; nil)
  108.                else let val c = case vl 
  109.                                   of (_::(VAR x)::_) => x
  110.                                    | _ => error "contmap contvars 124"
  111.                                 (* the 2nd arg must be a VAR *)
  112.                   in (contM c ; nil)
  113.                             end
  114.               end)        
  115.            else (add(g,vl);[g])
  116.        | SWITCH(v,c,el) => (fold incinfo el) nil
  117.        | BRANCH(_,_,_,e1,e2) => contvars e1 @ contvars e2
  118.        | SETTER(_,_,e) => contvars e
  119.        | LOOKER(_,_,_,e) => contvars e
  120.        | ARITH(_,_,_,e) => contvars e
  121.        | PURE(_,_,_,e) => contvars e
  122.        | FIX(fl,e) => fold contvars' fl (contvars e)
  123.        | _ => (error "contmap contvars 125")
  124.     and contvars' = 
  125.       fn ((fv,fa,ce),a) =>
  126.          if escapes fv 
  127.          then let val k = length(fa)
  128.                   val kl = contvars ce
  129.                in if (k > 2) orelse (k < 1) 
  130.           then (error "escaped funs have > 2, < 1 args z"; a)
  131.           else if k = 1 then (contM fv ; (kl@a))
  132.                        else (contM (nth(fa,1)) ; (kl@a))
  133.               end
  134.          else let val kl = contvars ce
  135.                in add(fv,(map VAR fa)); fv::(kl@a)
  136.               end
  137.  
  138.     val knownlabs = contvars'((fvar,fargs,cexp), [])
  139.  
  140.     val knownlabs = uniq knownlabs
  141.           
  142. (* run the stupid loop to gather all known functions' continuation variable 
  143.  * information . It's expected to be rewritten in the future .
  144.  *)
  145.     local val clicked = ref 0
  146.           fun click () = (inc clicked) 
  147.           fun cpass v = 
  148.            let val infolist = (find v) 
  149.                val newl = grouping infolist
  150.                fun proc vl =
  151.                  case divlist iscont (clean vl)                   
  152.                       of (nil,_) => ()
  153.                        | (_,nil) => ()
  154.                        | (_,vl0) => (click(); (app contM vl0))
  155.             in (app proc newl) 
  156.            end
  157.           fun loop () = let val _ = (app cpass knownlabs) 
  158.                             val k = (!clicked) before (clicked := 0)
  159.                          in if k = 0 then ()
  160.                             else loop ()
  161.                         end
  162.        in val _ = loop ()
  163.       end 
  164.  
  165.     fun substin(v,(env,fl)) = 
  166.          case lookup(v,env) of 
  167.             NONE => (let val v' = dupLvar v
  168.                  val x = mkLvar()
  169.                          val c = mkLvar()
  170.                          val _ = contM(c) 
  171.                          val tmp = (v',[x,c],APP(VAR v,[VAR x]))
  172.                        in ((v,v')::env,tmp::fl)
  173.                      end)
  174.           | SOME v' => (env,fl)
  175.  
  176. (* This is a very tricky function. (v,v') is added to env because 
  177.  * when v is stored back somewhere, we want to use v' again.
  178.  *)
  179.     fun substout(v,(env,fl)) = 
  180.          case lookup(v,env) of 
  181.             NONE => (let val v' = dupLvar v
  182.                  val x = mkLvar()
  183.                          val tmp = (v,[x],APP(VAR v',
  184.                                            [(VAR x),(INT 0)]))
  185.               in ((v,v')::env,tmp::fl)
  186.                      end)
  187.           | SOME v' => (env,fl)
  188.  
  189.     exception EB 
  190.     val ebtable : (bool * lvar list) Intmap.intmap = Intmap.new(32,EB)
  191.     fun ebinfo v = (Intmap.map ebtable v) 
  192.                      handle EB => (true,nil)
  193.     fun ebadd(v,info) = Intmap.add ebtable (v,info)
  194.     fun enterv(VAR v,l) = enter(v,l)
  195.       | enterv(_,l) = l (* error "contmap enterv 123" *)
  196.  
  197.     fun transform(RECORD(k,vl,w,e),env) = 
  198.          let val cl = uniq(sublist iscont (clean (map #1 vl)))
  199.              val (env',fl) = (fold substin cl) (env,nil)
  200.              val vl' = map (fn (x,p) => (glookup(x,env'),p)) vl
  201.              val (e',eb,free) = transform(e,env')
  202.              val eb' = if (cl=nil) then eb else true
  203.              val free' = merge(uniq(clean(map #1 vl)),rmv(w,free))
  204.              val free'' = remove(uniq(map #1 fl),free')  
  205.           in (fix(fl,RECORD(k,vl',w,e')),eb',free'')
  206.          end
  207.  
  208.       | transform(SELECT(i,v,w,e),env) =
  209.          if (iscont w) then 
  210.            (let val (env',fl) = substout(w,(env,nil))
  211.                 val w' = clookup(w,env')
  212.                 val (e',_,free) = transform(e,env')
  213.                 val free' = enterv(v,rmv(w',rmv(w,free)))
  214.              in (SELECT(i,v,w',fix(fl,e')),true,free')
  215.             end)
  216.          else (let val (e',eb,free) = transform(e,env)
  217.                    val free' = enterv(v,rmv(w,free))
  218.                 in (SELECT(i,v,w,e'),eb,free')
  219.                end)
  220.  
  221.       | transform(APP(VAR f,vl),env) = 
  222.          let val cl = sublist iscont (clean vl)
  223.              val k = if iscont f then (length cl) else (length cl)-1  
  224.           in if (k < 1) 
  225.              then (APP(VAR f,vl),false,enter(f,uniq(clean(vl))))
  226.              else (let fun sep(nil) = (nil,nil)
  227.                          | sep(hd::tl) = 
  228.                              if iscontv hd then ([hd],tl)
  229.                              else (let val (a,b) = sep tl
  230.                                     in (hd::a,b)
  231.                                    end)
  232.                        val (vl1,vl2) = if iscont f then (nil,vl) 
  233.                                        else sep(List.rev vl)
  234.                        val (vl1,vl2) = (List.rev vl1 , List.rev vl2)
  235.  
  236.                        (*** cl must not be empty because k > 0 here ***) 
  237.                        val cl = uniq(sublist iscont (clean vl2))
  238.                        val (env',fl) = (fold substin cl) (env,nil)
  239.                        val vl' = (map (fn x => glookup(x,env')) vl2)@vl1
  240.                        val free = enter(f,uniq(clean vl))
  241.                        val free' = remove(uniq(map #1 fl),free)
  242.                     in (fix(fl,APP(VAR f,vl')),true,free')
  243.                    end)
  244.          end
  245.       
  246.       | transform(SWITCH(v,c,el),env) = 
  247.          let fun f(e,(el,eb,free)) =
  248.                let val (e',eb',free') = transform(e,env)
  249.                 in (e'::el,eb orelse eb',merge(free,free'))
  250.                end
  251.              val (el',eb',free') = fold f el (nil,false,nil)
  252.           in (SWITCH(v,c,el'),eb',enterv(v,free'))
  253.          end
  254.  
  255.       | transform(SETTER(i,vl,e),env) =
  256.          let val cl = sublist iscont (clean vl)
  257.              val (env',fl) = (fold substin cl) (env,nil)
  258.              val vl' = map (fn x => glookup(x,env')) vl
  259.              val (e',eb,free) = transform(e,env')
  260.              val free' = merge(uniq(clean vl),free)
  261.              val (eb',free'') = if (cl=nil) then (eb,free')
  262.                                 else (true,remove(uniq(map #1 fl),free'))
  263.           in (fix(fl,SETTER(i,vl',e')),eb',free'')
  264.          end
  265.  
  266.       | transform(LOOKER(i,vl,w,e),env) =
  267.          let val cl1 = sublist iscont (clean vl)
  268.              val (env',fl) = (fold substin cl1) (env,nil)
  269.              val cl2 = sublist iscont [w]
  270.              val (env'',fl') = (fold substout cl2) (env',nil)
  271.              val vl' = map (fn x => glookup(x,env'')) vl
  272.              val w' = clookup(w,env'')
  273.  
  274.              val (e',eb,free) = transform(e,env'')
  275.              val eb' = if ((cl1=nil) andalso (cl2=nil)) then eb else true
  276.              val free' = merge(uniq(clean vl),rmv(w,free))
  277.              val free'' = remove(uniq(map #1 (fl@fl')),free')
  278.  
  279.           in (fix(fl,LOOKER(i,vl',w',fix(fl',e'))),eb',free'')
  280.          end
  281.  
  282.       | transform(ARITH(i,vl,w,e),env) =
  283.          let val cl1 = sublist iscont (clean vl)
  284.              val (env',fl) = (fold substin cl1) (env,nil)
  285.              val cl2 = sublist iscont [w]
  286.              val (env'',fl') = (fold substout cl2) (env',nil)
  287.              val vl' = map (fn x => glookup(x,env'')) vl
  288.              val w' = clookup(w,env'')
  289.  
  290.              val (e',eb,free) = transform(e,env'')
  291.              val eb' = if ((cl1=nil) andalso (cl2=nil)) then eb else true
  292.              val free' = merge(uniq(clean vl),rmv(w,free))
  293.              val free'' = remove(uniq(map #1 (fl@fl')),free')
  294.  
  295.           in (fix(fl,ARITH(i,vl',w',fix(fl',e'))),eb',free'')
  296.          end
  297.  
  298.       | transform(PURE(i,vl,w,e),env) =
  299.          let val cl1 = sublist iscont (clean vl)
  300.              val (env',fl) = (fold substin cl1) (env,nil)
  301.              val cl2 = sublist iscont [w]
  302.              val (env'',fl') = (fold substout cl2) (env',nil)
  303.              val vl' = map (fn x => glookup(x,env'')) vl
  304.              val w' = clookup(w,env'')
  305.  
  306.              val (e',eb,free) = transform(e,env'')
  307.              val eb' = if ((cl1=nil) andalso (cl2=nil)) then eb else true
  308.              val free' = merge(uniq(clean vl),rmv(w,free))
  309.              val free'' = remove(uniq(map #1 (fl@fl')),free')
  310.           in (fix(fl,PURE(i,vl',w',fix(fl',e'))),eb',free'')
  311.          end
  312.  
  313.       | transform(BRANCH(i,vl,c,e1,e2),env) =
  314.          let val cl = sublist iscont (clean vl)
  315.              val (env',fl) = (fold substin cl) (env,nil)
  316.              val vl' = map (fn x => glookup(x,env')) vl
  317.  
  318.              val (e1',eb1,free1) = transform(e1,env')
  319.              val (e2',eb2,free2) = transform(e2,env')
  320.              val eb = if (cl=nil) then (eb1 orelse eb2) else true
  321.              val free = merge(uniq(clean vl),merge(free1,free2))
  322.              val free' = remove(uniq(map #1 fl),free)
  323.       in (fix(fl,BRANCH(i,vl',c,e1',e2')),eb,free')
  324.          end
  325.           
  326.       | transform(FIX(l,e),env) =
  327.          let fun g(fe,(el,eb,free)) =
  328.                let val (fe',eb',free') = transfunc(fe,env)
  329.                 in (fe'::el,eb orelse eb',merge(free,free'))
  330.                end
  331.              val (e0,eb0,free0) = transform(e,env)
  332.              val (l',eb',free') = fold g l (nil,eb0,free0)
  333.              val free'' = remove(uniq(map #1 l'),free')
  334.           in (FIX(l',e0),eb',free'')
  335.          end
  336.  
  337.       | transform(_,env) =
  338.          error "illformed cexp in the contmap transforming process"
  339.  
  340.     and transfunc((fv,fa,ce),env) = 
  341.          let fun transf(fv,fa,ce) = 
  342.                    let val cl = sublist iscont fa
  343.                        val k = if iscont fv then length(cl) 
  344.                                else length(cl)-1 
  345.                        val cl' = if k < 1 then nil 
  346.                                  else if iscont fv then cl
  347.                                       else (List.tl(List.rev cl))
  348.                        val (env',fl) = (fold substout cl') (env,nil)
  349.                        val fa' = map (fn x => clookup(x,env')) fa 
  350.  
  351.                        val (ce',eb,free) = transform(ce,env')
  352.                        val eb' = if (cl'=nil) then eb else true
  353.                        val free' = remove(uniq(map #1 fl),free)
  354.                        val free'' = rmv(fv,remove(uniq(fa),free'))
  355.                        val _ = ebadd(fv,(eb',free''))
  356.  
  357.                     in ((fv,fa',fix(fl,ce')),eb',free'')
  358.                    end
  359.           in transf(fv,fa,ce)
  360.          end
  361.  
  362.     val ((fvar',fargs',cexp'),_,_) = transfunc((fvar,fargs,cexp),nil)
  363.  
  364.  in ((fvar',fargs',cexp'),iscont,ebinfo)
  365. end (* contmap *)
  366.  
  367. end (* ContMap *)
  368.